% *********************************************************
% *							  *
% * PISTOL-Portably Implemented Stack Oriented Language	  *
% *			Version 2.0			  *
% * (C) 1983 by	Ernest E. Bergmann			  *
% *		Physics, Building #16			  *
% *		Lehigh Univerisity			  *
% *		Bethlehem, Pa. 18015			  *
% *							  *
% * Permission is hereby granted for all reproduction and *
% * distribution of this material provided this notice is *
% * included.						  *
% *							  *
% *********************************************************
% BASIC DEFINITIONS FOR PISTOL 2.0
%
% DECIMAL mode initially
%
+5 W * USER + W@ W@ % used for 'LAST-PRIMITIVE
'W*  W 1 - IF : W * ;
	ELSE $: ;$
	THEN
'USER+ USER IF $: USER + ;$
		ELSE $: ;$
		THEN
'TRANS $: W* USER+ ;$ % TRANSLATES LOGICAL ADDRESSES TO ACTUAL RAM ADDR.
		% TRANS MUST USE "$:" FOR THE 'DIS PACKAGE
'TRANS@ : TRANS W@ ;
'ARGPATCH : +5 TRANS@  W@ W + W! ; % for 'CONSTANT 'VARIABLE, 'ARRAY
'CONSTANT : : 0 ; ARGPATCH ;

'LAST-PRIMITIVE 		CONSTANT

-1	'TRUE			CONSTANT
0	'FALSE			CONSTANT

-21	TRANS@	'MININT		CONSTANT
-20	TRANS@	'MAXLINNO	CONSTANT
-19	TRANS@	'CHKLMT		CONSTANT
-18	TRANS@	'RAMMIN		CONSTANT
-17	TRANS@	'STRINGSMIN	CONSTANT
-16	TRANS@	'STRINGSMAX	CONSTANT
-15	TRANS@	'VBASE		CONSTANT
-14	TRANS@	'VSIZE		CONSTANT
VBASE VSIZE W* + 'VMAX		CONSTANT
-13	TRANS@	'CSIZE		CONSTANT
-12	TRANS@	'LSIZE		CONSTANT
-11	TRANS@	'RSIZE		CONSTANT
-10	TRANS@	'SSIZE		CONSTANT
-9	TRANS@	'LINEBUF	CONSTANT
LINEBUF 200 + 'EDITBUF		CONSTANT
-8	TRANS@	'COMPBUF	CONSTANT
-7	TRANS@	'RAMMAX		CONSTANT
-6	TRANS@	'MAXORD		CONSTANT
-5	TRANS@	'MAXINT		CONSTANT
-4	TRANS@	'VERSION	CONSTANT
-3	TRANS@ 'NEWLINE		CONSTANT
-2	TRANS@	'READ_PROTECT	CONSTANT
-1	TRANS@	'WRITE_PROTECT	CONSTANT

'ON : TRUE SWAP W! ;
'OFF : FALSE SWAP W! ;
'INFILE : +7 TRANS@ ;

'BYE : +31 TRANS ON ;
+34	TRANS	'ABORT-PATCH	CONSTANT
+33	TRANS	'CONVERT-PATCH	CONSTANT
+32	TRANS	'PROMPT-PATCH	CONSTANT
+29	TRANS '(PISTOL<)	CONSTANT
+28	TRANS '.V		CONSTANT
+24	TRANS '#GET-ADDR CONSTANT % FOR PATCHING #GETLINE
+23	TRANS 'TAB-SIZE		CONSTANT
+22	TRANS 'TRACE-ADDR 	CONSTANT
+21	TRANS 'ENDCASE-PATCH	CONSTANT
+20	TRANS 'COLUMN		CONSTANT
+19	TRANS 'TERMINAL-WIDTH	CONSTANT
+18	TRANS '#LINES		CONSTANT
+17	TRANS 'TERMINAL-PAGE	CONSTANT
+16	TRANS 'COMPILE-END-PATCH CONSTANT
+15	TRANS 'TRACE-LEVEL	CONSTANT % USED AS BOOLEAN
					% AND LEVEL INDICATOR
+13	TRANS 'RAISE		CONSTANT
+11	TRANS 'NEXTCH^		CONSTANT
+10	TRANS 'CONSOLE		CONSTANT
+9	TRANS 'ECHO		CONSTANT
+8	TRANS 'LIST		CONSTANT
+6	TRANS 'PREVIOUS		CONSTANT % UPDATED BY (V)FIND
+5	TRANS 'CURRENT		CONSTANT
+4	TRANS 'OLD-EOSTRINGS	CONSTANT % END OF PERMANENT
					% STRINGS VARIABLE
+3	TRANS 'CURRENT-EOSTRINGS CONSTANT
+2	TRANS '.D		CONSTANT
+1	TRANS '.C		CONSTANT
+0	TRANS 'RADIX		CONSTANT
STRINGSMIN 'RADIX-INDICATOR	CONSTANT
STRINGSMIN 1 + 'SYNTAXBASE	CONSTANT

'NOP : ;
'DUP : 0 S@ ;
'1+ : 1 + ;
'1- : 1 - ;
'W+ : W + ;
'W- : W - ;
'W<- : SWAP W! ;
'1+W! : DUP W@ 1+ W<- ;
'W+W! : DUP W@ W+ W<- ;
'CR : NEWLINE TYO ;
'SPACE : 32 TYO ;
'SPACES : 0 DO SPACE LOOP ;
'DDUP : 1 S@ 1 S@ ;
'OVER : 1 S@ ;
'2OVER : 2 S@ ;
'3OVER : 3 S@ ; % USED BY DIS PACKAGE(DON'T CHANGE!)
'UNDER : SWAP DROP ;
'TYPE : 0 DO DUP C@ TYO 1+ LOOP DROP ;
'LT : MININT SWAP 1- .. ;
'GT : 1+ MAXINT .. ;
'LINE-SPACE? : COLUMN W@ + TERMINAL-WIDTH W@ LT
	IF ELSE CR THEN ;

'MSG : DUP C@ LINE-SPACE?
	 DUP 1+ SWAP C@ TYPE ;

'IFCR : COLUMN W@ 0 GT IF CR THEN ;
'ERR : IFCR ABORT ;

'MERR : CONSOLE ON MSG ERR ;


'INDENT : DUP TERMINAL-WIDTH W@ LT IF
	COLUMN W@ - SPACES
	ELSE IFCR DROP
	THEN ;

'TAB : 9 TYO ;

'TABS : 0 DO TAB LOOP ;

'ALLOT : W* .D W@ + .D W! ; % advances dictionary pointer
			% by the amount given by top of stack
'W, :		% PLACES TOS AT END OF DICTIONARY
	.D W@ W! 1 ALLOT
	;
'VARIABLE : : 3 ;	% create definition
	.D W@ ARGPATCH	% point it at end of dictionary
	W,		% initialize variable
	;		% finish with allocating space
'ARRAY : : 3 ;		% create definition
	.D W@ ARGPATCH	% point it at end of dictionary
	ALLOT ;		% allocate requested space and ;


% VOCABULARY RELATED DEFINITIONS:
'> : .V W@ DUP VBASE GT	% "POPS" VOCABULARY STACK
	IF W- .V W!
	ELSE "*** VSTACK UNDERFLOW***" MERR
	THEN
	;

'<V :	% TRANSFERS TOS TO TOP OF VSTACK
	.V W@ DUP VMAX LT
	IF W+ DUP .V W! W!
	ELSE "*** VSTACK OVERFLOW***" MERR
	THEN
	;

'PISTOL< : (PISTOL<) <V ;


(PISTOL<)	'BRANCH-LIST	VARIABLE

'BRANCH :	% CREATES AN ARRAY OF TWO ELEMENTS
		% AND A PROCEDURE THAT PUSHES A ^
		% TO THE FIRST ELEMENT OF THE ARRAY
		% THIS FIRST ELEMENT CONTAINS A ^
		% TO THE CURRENT HEAD OF THE VOCABULARY
		% BRANCH AND THE SECOND ELEMENT IS A
		% BACKWARD LINK TO THE PREVIOUS HEAD.
		% BRANCH-LIST CONTAINS THE ^ TO THE
		% THREADED LIST OF BRANCHES THAT HAVE
		% BEEN DEFINED; THE BACKWARD LINK FOR
		% (PISTOL<) IS "NIL"
: 3 <V ; .D W@ ARGPATCH
	0 .D W@ W!
	BRANCH-LIST W@ .D W@ W+
	W!
	.D W@ BRANCH-LIST
	W!
	2 ALLOT
	;

'UNLINKED< BRANCH	% CAN BE USED FOR RARELY USED, OBSCURE,
		% OR DANGEROUS WORDS

CURRENT W@ W@ W+ W@ '(UNLINKED<) CONSTANT	% PROVIDES POINTER
					% TO HEAD OF THIS VOCAB.


'3W- : W- W- W- ;

'BLIST :	% LISTS THE NAMES OF ALL DEFINED BRANCHES
	BRANCH-LIST W@
	BEGIN
		DUP W+ W@ DUP	% GET LINK
		IF
			SWAP 3W- 3W-
			W@ MSG CR
	REPEAT
	DROP DROP
	IFCR
	'PISTOL< MSG
	;

% DO LOOP INDICES:
'I : 0 L@ ;
'J : 3 L@ ;
'K : 6 L@ ;

'I' : 2 L@ 1 L@ + 1- 0 L@ - ;
'J' : 5 L@ 4 L@ + 1- 3 L@ - ;
'K' : 8 L@ 7 L@ + 1- 6 L@ - ;

% SOME LOGICAL OPERATORS:

'LOR : IF DROP TRUE THEN ;		% LOGICAL OR

'LAND : IF ELSE DROP FALSE THEN ;	% LOGICAL AND

'LNOT : IF FALSE ELSE TRUE THEN ; % LOGICAL NEGATION

'MINUS : 0 SWAP - ;
'LTZ	: MININT -1 .. ;
'GTZ	: 1 MAXINT .. ;
'EQZ	: LNOT	;
'ABS	: DUP LTZ IF MINUS THEN ;
'EQ	: - LNOT ;
'LE : MININT SWAP .. ;
'GE : MAXINT .. ;
'MIN : DDUP GE IF SWAP THEN DROP ;

'MAX : DDUP GE IF THEN SWAP DROP ;


% NUMBER OUTPUT ROUTINE:

% ASCII <-- DIGIT
'ASCII : DUP 9 GT IF 55
		ELSE 48
	THEN + ;

'<U#> : -1 SWAP
	BEGIN RADIX W@ /MOD ABS SWAP DUP LNOT END
	DROP ;

'#TYPE : BEGIN DUP -1 GT IF ASCII TYO REPEAT DROP ;

'= : DUP 0 LT IF  45 TYO MINUS THEN
	<U#> #TYPE ;
'? : W@ = ;

% BELOW ARE WORDS THAT CONTROL DISPLAY OF CODE PRODUCED
% BY THE COMPILER; CAN BE USEFUL FOR DEBUGGING AND EDUCATION

'CODESHOW : IFCR "COMPILE BUFFER CONTAINS:" MSG CR
	COMPBUF	BEGIN DUP ? TAB W+
			.C W@ OVER GT LNOT
		END
	DROP IFCR
	;
'SHOWCODE : 0 COMPILE-END-PATCH W! ; 'CODESHOW FIND ARGPATCH

'NOSHOWCODE : COMPILE-END-PATCH OFF ;

'PROMPT :		% DUPLICATES PRIMITIVE PROMPT
	IFCR		% FUNCTION
	SP IF SP = THEN	% EXCEPT STACK SIZE SHOWN
	RADIX-INDICATOR C@ TYO
	SYNTAXBASE MSG
	"> " MSG
	;
'PROMPT FIND PROMPT-PATCH W!	% PATCHING IT

'ADDRESS :	DUP FIND DUP
		IF
			UNDER
		ELSE
			IFCR 39 TYO DROP MSG
			" NOT FOUND" MERR
		THEN
	;

'/ : /MOD DROP ;
'MOD : /MOD UNDER ;


% CHANGING NUMBER BASES:
'HEX : 72 RADIX-INDICATOR C! 16 RADIX W! ;
'DECIMAL : 88 RADIX-INDICATOR C! 10 RADIX W! ;
'OCTAL : 81 RADIX-INDICATOR C! 8 RADIX W! ;
'BINARY : 66 RADIX-INDICATOR C! 2 RADIX W! ;


%
'STACK : IFCR 40 TYO SP = 41 TYO % (STACKSIZE)
	SP SP 12 MIN 1- 0 DO 2 SPACES DUP S@ = 1- LOOP
	DROP ;
%
'RSTACK : IFCR 'R( MSG RP 1- = 41 TYO % RSTACK SIZE
	RP 1- DUP 12 MIN 0 DO 2 SPACES DUP R@ = 1-
	LOOP DROP ;

% RECURSE ALOWS ROUTINE OR COMPBUF TO CALL ITSELF
'RECURSE :	1 R@ W-	% FIND IN WHICH WORD
		0 R@ W- % FIND WHERE IS RECURSE USED
		W!	% PATCH
	R> W- <R		% BACKUP TO EXEC PATCH
	;
%
'TELL : W- W- W@  MSG ;

'NEXT-LINK : 3W- W@ ;
%
% THIS BOMBS WHEN > NUMINSTRUCTIONS
'PNAME : DUP IF
		LAST-PRIMITIVE
		BEGIN	DUP
			IF	DDUP W@ EQ
				IF	TELL	TRUE
				ELSE	NEXT-LINK FALSE
				THEN
			ELSE	'(NO_NAME) MSG	LNOT
			THEN
		END
		DROP
	    ELSE '; MSG DROP
	    THEN
	;
%
'NAME : DUP PRIMITIVE? IF
	PNAME
	ELSE TELL
	THEN ;


% VOCABULARY MAINTENANCE PACKAGE:

% LLIST ADDRESS AND NAME:
'LNAME : DUP = 3 SPACES NAME CR ;

% LIST LAST TEN WORDS:
'NEXT10 : IFCR 10 0 DO DUP LNOT IF ERR THEN
		DUP LNAME NEXT-LINK LOOP
	;
'TOP10 :	% OF VOCBULARY TO WHICH DEFINITIONS
		% ARE CURRENTLY BEING ADDED
	CURRENT W@ W@ NEXT10 ;

'VLIST : % TOP TEN WORDS IN FIRST VOCABULARY TO BE SEARCHED
	.V W@ W@ W@ NEXT10 ;

0 'ITEM VARIABLE

'FIND_PREVIOUS,NEXT :	% GIVEN THREAD, FINDS ENTRY MOST
			% RECENT AFTER ITEM AND THE ONE
			% JUST BEFORE IT
			% EXIT: PREV(LATER CHRON),NEXT
	BEGIN
		DUP NEXT-LINK DUP ITEM W@ GT
	IF
		UNDER
	REPEAT
	;
% IMPROVED FORGET DEVELOPED AUG 8, 1982

0 'FENCE	VARIABLE

'VFORGET :	% TOS IS A VOCABULARY TO BE CUT BACK
		% TO BEFORE "ITEM"
	DUP W@
	DUP ITEM W@ GT
	IF
		FIND_PREVIOUS,NEXT UNDER W<-
	ELSE
		DROP DROP
	THEN
	;


'FORGET : ADDRESS DUP ITEM W!	% SIMPLIFIES LOGIC!
	FENCE W@ GT
	IF
		VBASE .V W!	% RESET VSTACK
		(PISTOL<) CURRENT W!
		BRANCH-LIST W@
		BEGIN
			ITEM W@ OVER LT
		IF
			W+ W@
		REPEAT
		DUP BRANCH-LIST W!
		BEGIN		% TRIM EACH VOCAB
			DUP VFORGET
			W+ W@ DUP
		IF
		REPEAT
		DROP
		ITEM W@
		DUP W- W- W@
		DUP OLD-EOSTRINGS W!
		CURRENT-EOSTRINGS W!
		3W- DUP W@ CURRENT W@ W!
		W- .D W!
	ELSE
		"BELOW FENCE" MERR
	THEN
;

'FORGET FIND FENCE W!	% SET FENCE

'VADDRESS :	% TAKES NAME,VOCAB ON STACK; GETS ITS ADDRESS
		% RETURNS IT ON TOP OF STACK IF IN VOCAB
	OVER SWAP
	VFIND
	DUP IF UNDER
		ELSE 39 TYO DROP MSG
		" NOT IN VOCABULARY" MERR
		THEN
	;

'REMOVE :	% TAKE NAME,VOCAB ON STACK ;GET ITS ADDRESS
		% (SAVED IN ITEM); PUT PREVIOUS-> NEXT
	DDUP VADDRESS DUP ITEM W!
	DUP 2OVER W@ -			% NOT LAST DEFINED?
	IF NEXT-LINK PREVIOUS W@ 3W-	% PREV->NEXT
	ELSE NEXT-LINK OVER		% VOCAB->NEXT
	THEN W! DROP DROP
	;

'ADD_LINK :	% GIVEN VOCABULARY, LINK IN ITEM IN
		% PROPER CHRONOLOGICAL ORDER
	DUP W@ ITEM W@ LT
	IF
		DUP W@ ITEM W@ 3W- W!	% UPDATE VOCAB
		ITEM W@ W<-		% INSTALL LINK TO
					% OLD HEAD
	ELSE
		W@ FIND_PREVIOUS,NEXT
		ITEM W@ 3W- W!		% ADJUST LINK OF ITEM
		3W- ITEM W@ W<- 	% LINK PREVIOUS
	THEN
;

'UNLINK :	% TAKES STRING ON TOS AND UNLINKS IT FROM
		% SEARCH PATH AND LINKS IT INTO THE
		% UNLINKED< VOCABULARY BRANCH
	CURRENT W@ REMOVE
	(UNLINKED<) ADD_LINK
	;

'RELINK :	% TAKES NAME ON TOS AND REMOVES IT FROM THE
		% UNLINKED< VOCABULARY; LINKS IT INTO THE
		% CURRENT VOCABULARY
	(UNLINKED<) REMOVE
	CURRENT W@ ADD_LINK
	;

'DEFINITIONS :	% SETS CURRENT TO TOP VOCABULARY IN  IN VSTACK
	.V W@ W@ CURRENT W!
	;

'LAST-PRIMITIVE	UNLINK
'W,		UNLINK
'ALLOT		UNLINK
'CODESHOW	UNLINK
'VFORGET	UNLINK
'REMOVE		UNLINK
'ITEM		UNLINK
'LNAME		UNLINK
'FIND_PREVIOUS,NEXT	UNLINK
'ADD_LINK	UNLINK
'<V		UNLINK
'PROMPT		UNLINK
'TELL		UNLINK
'PNAME		UNLINK

% CASE INDICES:
'ICASE : 0 CASE@ ;
'JCASE : 2 CASE@ ;
'CASE-ADDR : 1 CASE@ ;
'(ENDCASE) : IFCR "ENDCASE ENCOUNTERED WITH VALUE = " MSG
	ICASE = " AT " MSG CASE-ADDR = ERR ;
'(ENDCASE) ADDRESS
ENDCASE-PATCH W!	% PATCH ENDCASE

% SPECIAL STRING ROUTINES:

% PACK puts TOS onto the end of the strings area.
'PACK : CURRENT-EOSTRINGS W@ C!
	CURRENT-EOSTRINGS 1+W! ;

'=PACK : CURRENT-EOSTRINGS W@ <R
	CURRENT-EOSTRINGS 1+W!
	DUP LTZ IF 45 PACK MINUS THEN
	<U#> BEGIN DUP 0 GE IF ASCII PACK REPEAT
	DROP R> CURRENT-EOSTRINGS W@ OVER -
	1- OVER C! ;
% =PACK IS USED TO CREATE A NUMBER STRING. IT
% TAKES THE TOP SIGNED NUMBER ON STACK AND CONVERTS IT
% TO A STRING THAT COULD BE OUTPUT BY MSG

% THE NEXT TWO ROUTINES TAKE AS INPUT
% A BUNCH OF STRING POINTERS
% AND THEIR NUMBER FROM THE TOP OF STACK.
'MSGS-COUNT : SP 1- OVER LT IF "NOT ENOUGH STRINGS"
	MERR THEN
	0 SWAP 1+ 1 DO I S@ C@ + LOOP ;

'MSGS : DUP <R DUP <R MSGS-COUNT LINE-SPACE?
	R> 0 DO I' S@ MSG LOOP R> 0 DO DROP LOOP
	;

'ENDCASE-PATCH	UNLINK
'MSGS-COUNT	UNLINK
'LINE-SPACE?	UNLINK

% In the above, MSGS will output a bunch of strings
% that were left on stack IN THE ORDER they were placed
% on stack, trying to place them all on the same line;
% failing that, it will try and not split the individual
% strings across lines.  It will be used to improve the:

% DISASSEMBLER PACKAGE

'DIS-TRIAL :	% CONTAINS ALL REL-OPS IN THE KERNEL
	DO +LOOP
	DO LOOP
	IF ELSE
	THEN
	OFCASE C: ;C ENDCASE
	: ;
	$: ;$
;
'NEXT-TRIAL :	% CONVENIENCE TO STEP THROUGH DIS-TRIAL
	W+ W+ DUP W@
	;
'OP-TYPE :	% USED TO DEFINE WORDS FOR TESTING KERNEL OPS
	DUP	:
		3 EQ IF "" TRUE ELSE FALSE THEN
		;
		CURRENT W@ W@ 6 W* + W!	% GET THE NAME OF DEFINITION
		ARGPATCH	% RECORD THE VALUE OF OPCODE
	;

'3OVER FIND	% IT STARTS WITH A LITERAL CONSTANT
W@ 'LITERAL	CONSTANT

'Z : 'Z ;
'Z  FIND	% IT STARTS WITH A STRING LITERAL
W@ 'STRING-LIT	CONSTANT

'TRANS FIND	% IT IS A "$:" WORD
W- W@ '[$:]	OP-TYPE

'DIS-TRIAL FIND
DUP W- W@ '[:]		OP-TYPE
NEXT-TRIAL '(+LOOP)	OP-TYPE
NEXT-TRIAL '(DO)	OP-TYPE
NEXT-TRIAL '(LOOP)	OP-TYPE
NEXT-TRIAL '(IF)	OP-TYPE
NEXT-TRIAL '(ELSE)	OP-TYPE
NEXT-TRIAL '(OFCASE)	OP-TYPE
NEXT-TRIAL '(C:)	OP-TYPE
W+ W+
NEXT-TRIAL '(:)		OP-TYPE
NEXT-TRIAL '(;)		OP-TYPE
W-
NEXT-TRIAL '($:)	OP-TYPE
DROP

'REL-OP	:
	SWAP W+ W@ =PACK
	" [" SWAP ']
	4 MSGS W W+
	;
'DIS-TOKEN :
	DUP W@ OFCASE
	(;)	C: MSG DROP W ;C
	LITERAL EQ	C: W+ W@ =PACK MSG W W+ ;C
	STRING-LIT EQ	C: W+ W@ '" SWAP OVER
				3 MSGS W W+	;C
	(DO)	C: REL-OP ;C
	(LOOP)	C: REL-OP ;C
	(+LOOP)	C: REL-OP ;C
	(IF)	C: REL-OP ;C
	(ELSE)	C: REL-OP ;C
	(OFCASE) C: REL-OP ;C
	(C:)	C: REL-OP ;C
	(:)	C: REL-OP ;C
	($:)	C: REL-OP ;C
	TRUE	C: NAME DROP W ;C
	ENDCASE
	;
'WORD-ID : IFCR 39 TYO DUP MSG SPACE ADDRESS ;

'DIS : WORD-ID
	DUP W- DUP W@ DUP
	[:] IF MSG DROP
	ELSE [$:] IF MSG
		ELSE "NON-STANDARD IMMEDIATE WORD"
			MERR
		THEN
	THEN
	NEXT-LINK	% GET ^ TO END OF CODE
	SWAP	DO
		TAB I DIS-TOKEN
		+LOOP
	TAB '; MSG
;

'Z		UNLINK
'CASE-ADDR	UNLINK
'(ENDCASE)	UNLINK
'PACK		UNLINK
'LITERAL	UNLINK
'STRING-LIT	UNLINK
'[:]		UNLINK
'DIS-TRIAL	UNLINK
'NEXT-TRIAL	UNLINK
'OP-TYPE	UNLINK
'[$:]		UNLINK
'(+LOOP)	UNLINK
'(DO)		UNLINK
'(LOOP)		UNLINK
'(IF)		UNLINK
'(ELSE)		UNLINK
'(OFCASE)	UNLINK
'(C:)		UNLINK
'(:)		UNLINK
'($:)		UNLINK
'REL-OP		UNLINK
'DIS-TOKEN	UNLINK

% TRACE PACKAGE:

% ROUTINE THAT DISPLAYS THE STATE OF THE MACHINE
% AT EACH TRACE AND TERMINATES TRACE AT END OF
% ROUTINE BEING TRACED.
'(TRACE) : STACK 48 INDENT 0 R@ W@ DUP
	(;)	IF MSG DROP 0 TRACE-LEVEL W!
		ELSE NAME 2 SPACES
		THEN
	;
% PERFORM PATCH:
'(TRACE) ADDRESS TRACE-ADDR W!

'TRACE : WORD-ID "BEING TRACED:" MSG
		RP 3 + TRACE-LEVEL W!
		EXEC IFCR "TRACE COMPLETED" MSG
		CR
	;

'(;)		UNLINK
'WORD-ID	UNLINK
'(TRACE)	UNLINK


% EDIT PACKAGE:


+27	TRANS	'OUTFILE-STATUS		CONSTANT
+26	TRANS	'INPUTFILE-STATUS	CONSTANT
STRINGSMAX 200 -
	'SAFE-END		CONSTANT
1	'OLDLINE#	VARIABLE
EDITBUF	'OLDLINE^	VARIABLE
EDITBUF		'EOT	VARIABLE

'NEWF : 1 OLDLINE# W!
	EDITBUF OLDLINE^ W!
	0 EDITBUF C!
	EDITBUF EOT W!
	;

NEWF	% INITIALIZE EDITBUFFER

'NEXTLINE : DUP C@ DUP IF + 1+
		ELSE "***NO SUCH LINE***" MERR
		THEN ;

'LISTALL : 1 EDITBUF
	BEGIN DUP C@
	IF OVER = ": " MSG DUP MSG NEXTLINE
	SWAP 1+ SWAP REPEAT DROP DROP ;

'ILLEGLIN : "***ILLEGAL LINE #***" MERR ;


'LFIND : DUP OLDLINE# LT IF DUP 1 MAXLINNO ..
				LNOT IF ILLEGLIN THEN
		EDITBUF OVER 1 DO
			NEXTLINE LOOP
		ELSE DUP OLDLINE#	% CALCULATE # OF
			- OLDLINE^ W@	% LINES NEEDED TO
			SWAP 0 DO
			NEXTLINE LOOP	% ADVANCE
		THEN
		SWAP OLDLINE# W!
		DUP OLDLINE^ W!
	;

'LDIR : % CHARACTER BLOCK MOVE, INCREASING
	% ON ENTRY: SOURCE, DESTINATION, #
	% ON EXIT: SOURCE+#, DESTINATION+#

	0 DO OVER C@ OVER C!
		1+ SWAP 1+ SWAP
	LOOP
	;

'LDDR :	% CHARACTER BLOCK MOVE, DECREASING
	% ON ENTRY: SOURCE, DESTINATION, #
	% ON EXIT: SOURCE-#, DESTINATION-#

	0 DO
	OVER C@ OVER C!
	1- SWAP 1- SWAP
	LOOP
	;

'#GETLINE :	% TAKES THE LINE NUMBERED BY THE
		% TOP OF THE STACK AND TRANSFERS
		% IT INTO LINEBUF
		LFIND
		LINEBUF 1+ NEXTCH^ W!	% SYSTEM ^S
		LINEBUF
		OVER C@ IF	% NOT NULL LINE?
			OVER C@ 1+
			LDIR
		ELSE
			1 OVER C! 1+ NEWLINE OVER C!
		THEN
		DROP DROP
		% ECHO IF APPROPRIATE:
		ECHO W@ IF LINEBUF MSG THEN
	;

'#GETLINE FIND #GET-ADDR W!	% DO THE PATCH


'MTUP :	% ON ENTRY: ^ TO BAS OF BLOCK BOUNDED BY EOT
	% ON EXIT: ^ TO BASE OF MOVED BLOCK AT STRINGSMAX

	EOT W@ 1+ SWAP -	% # BYTES
	EOT W@ SWAP	% SOURCE
	STRINGSMAX SWAP	% DESTINATION
	LDDR
	UNDER 1+
	;

'OVERWRITE :	% TAKES THE ^BOTTOM OF TEXT TO BE MOVED DOWN
		%	^TEXT TO BE OVERWRITTEN
		% AND	^LAST CHAR OF TEXT TO BE MOVED DOWN

		% ON EXIT LEAVES NO ARGS BUT HAS ADJUSTED EOT

	1+ 2OVER -
	LDIR
	1-
	EOT W!
	DROP
	;


'MTDN :	% ON ENTRY: ^ TO BASE OF BLOCK AT STRINGSMAX
	%	AND ^ TO BASE OF DESTINATION

	STRINGSMAX
	OVERWRITE
	;



'LENTER : % TAKES ADDRESS ON TOP OF STACK AND MOVES INPUT
	  % INPUT LINE THERE; LEAVES A POINTER TO NEXT AVAILABLE
	  % LOCATION.
	LINEBUF NEXTLINE LINEBUF
	DO
		I C@ OVER C! 1+
	LOOP
	;

'1POSARG? :	% TESTS STACK TO SEE IF THERE IS EXACTLY
		% ONE ARGUMENT; IT MUST BE POSITIVE.

		% ON EXIT IT LEAVES THAT ARGUEMENT.

	SP 1 EQ OVER -1 GT LAND
	LNOT
	IF "NOT SINGLE, POSITIVE ARGUEMENT" MERR
	THEN
	;

'ARG#ERR : "WRONG NUMBER OF ARGUMENTS" MERR ;

'LI : SP OFCASE
	EQZ	C: LISTALL ;C
	1 EQ	C: LFIND MSG ;C
	2 EQ	C: DDUP GT IF OVER + 1- THEN
			1+ SWAP DO I = ": " MSG
					I LFIND MSG LOOP ;C
	TRUE	C: ARG#ERR ;C
	ENDCASE
	;


'INPUT :
	1POSARG?
		DUP
		LFIND
		MTUP
		SWAP DUP LFIND
		BEGIN
			SWAP DUP
			= ": " MSG
			1+ SWAP
			GETLINE
			LINEBUF C@ 1 GT
		IF
			LENTER
		REPEAT
		UNDER
		MTDN
	;

'(DELETE) :	LFIND
		DUP NEXTLINE
		SWAP
		EOT W@
		OVERWRITE
	;

'DELETE : 1POSARG?
		(DELETE)
	;

'REPLACE : 1POSARG?
		DUP
		(DELETE)
		INPUT
	;

'DELETES : SP 2 EQ
		IF
		DDUP LT IF OVER - 1+ THEN % IF ARG1<ARG2
					% THEN INTERPRET
					% AS RANGE !
			0 DO DUP (DELETE) LOOP
			DROP
		ELSE
			ARG#ERR
		THEN
	;

'1READ :	% NO ERROR CHECKING
		% TAKES A LINE FROM THE INPUT FILE AND
		% APPENDS IT TO THE END OF THE
		% TEXT IN THE EDIT BUFFER.

	READLINE
	0 EOT W@
	LENTER
	DUP
	EOT W!	% UPDATE EOT
	C!	% EMPLACE NEW EMPTY LINE
	;

'READ :	% TAKES A SINGLE ARGUMENT FROM STACK AS THE
	% NUMBER OF LINES TO BE READ FROM THE INPUT
	% FILE AND APPEND THEM TO THE END OF THE EDIT
	% BUFFER.

	1POSARG?
	BEGIN
		EOT W@ SAFE-END LT
		OVER LAND
	IF
		1READ
		1-	% DECREASE COUNT
	REPEAT
	IF
		"PREMATURE EOF ENCOUNTERED" MSG
	THEN
	;

'WRITE :	% TAKES A SINGLE ARGUMENT FROM STACK AS
		% THE NUMBER OF LINES TO BE TRANSFERRED
		% FROM THE BEGINNING OF THE EDIT BUFFER
		% TO THE OUTPUT FILE.
	1POSARG?
	1 LFIND	% ADJUSTS POINTERS
	BEGIN	% IF NOT EOT, STILL MORE LINES TO SEND
		DUP C@ 2OVER LAND
	IF
		DUP WRITELINE
		NEXTLINE
		SWAP 1- SWAP
	REPEAT
		% AT THIS POINT HAVE POINTER TO TEXT
		% THAT IS NOT YET SENT AND NUMBER OF LINES
		% YET TO BE SENT AFTER EOT

	EDITBUF	% DESTINATION
	EOT W@
	OVERWRITE
	IF IFCR "PREMATURE EOT ENCOUNTERED" MSG THEN
	;


'FINISH :	% USED AT END OF EDIT SESSION TO TRANSFER
		% CONTENTS OF EDIT BUFFER AND ANY ADDITIONAL
		% REMAINING TEXT IN THE INPUT FILE TO THE
		% OUTPUT FILE.

	EDITBUF
	BEGIN	% EMPTY EDIT BUFFER
		DUP C@
	IF
		DUP
		WRITELINE
		NEXTLINE
	REPEAT
	DROP
	NEWF
	BEGIN	% TRANSFER REMAINDER OF INPUT FILE
		INPUTFILE-STATUS
		W@ -1 GT
	IF
		READLINE
		LINEBUF WRITELINE
	REPEAT
	% SUMARIZE:
	IFCR
	"SUMARIZING: " MSG
	INPUTFILE-STATUS W@ MINUS =
	" LINES READ AND " MSG
	OUTFILE-STATUS W@ MINUS =
	" LINES WRITTEN." MSG
	% CLOSING STATUS OF OUTPUT FILE:
	+1 OUTFILE-STATUS W!
	;

'MTDN		UNLINK
'LENTER		UNLINK
'1POSARG?	UNLINK
'ARG#ERR	UNLINK
'(DELETE)	UNLINK
'1READ		UNLINK
'OLDLINE^	UNLINK
'EOT		UNLINK
'NEXTLINE	UNLINK
'ILLEGLIN	UNLINK
'LFIND		UNLINK
'LDIR		UNLINK
'LDDR		UNLINK
'#GETLINE	UNLINK
'MTUP		UNLINK
'OVERWRITE	UNLINK

% TEST INPUT:
1 INPUT
THIS IS THE FIRST LINE
THIS IS THE SECOND LINE
THIS IS THE THIRD LINE
THIS IS THE FOURTH LINE
THIS IS THE LAST LINE


% HELP PACKAGE (JUNE 15, 1982)

58 ':' CONSTANT
41 ')' CONSTANT
65 'A' CONSTANT
81 'Q' CONSTANT
'UC :  % l.c. -> U.C.
     DUP
     97 122 ..
     IF
        32 -
     ELSE
     THEN
    ;

'COL#? :	% RETURNS THE # OF ':' AT START OF LINE
0 LINEBUF 1+
BEGIN DUP C@ :' EQ IF
1+ SWAP 1+ SWAP
REPEAT
DROP
;

'TYIL : % READ FIRST CHAR FROM KEYBOARD; EXHAUST REST OF LINE
	TYI DUP NEWLINE -
	IF BEGIN TYI NEWLINE EQ END
	THEN
;

'MENU : % ON ENTRY NOTHING
        % ON EXIT: # OF LINES-1 (IF NO MENU, RETURN -1)
        -1
         BEGIN
           GETLINE
           COL#? LNOT IF
                       1+ DUP IF 
                                 DUP
                                 1- A' + TYO
                                 )'      TYO
                                         TAB
                              THEN
                       LINEBUF MSG
         REPEAT
        ;
'TEXT :  % PRINTS LINES UNTIL A LINE STARTING WITH A ":"
         % NO STACK ACTIVITY
         BEGIN
           GETLINE
           COL#? LNOT
         IF
           LINEBUF 1+ LINEBUF C@ TYPE
         REPEAT
       ;
'LOCATE :  % INPUT: SELECTION #, DELIM #
           % OUTPUT: NONE
          SWAP 1- 0
          DO
             BEGIN
                GETLINE
                COL#?
                OVER
                EQ
             END
           LOOP
           DROP
         ;
'SELECTION : % INPUT: HIGHEST ACCEPTABLE
             % OUTPUT: POSITIVE # OF SELECTION
      0
       BEGIN
	DROP
          "ENTER LETTER OF SELECTION(Q TO ABORT):" MSG
           0 #LINES W!   % RESET LINE COUNT
           0 COLUMN W!   % RESET COL COUNT
          TYIL UC 
	  DUP Q' EQ IF ABORT THEN
	  A' - 1+
	  DUP 1 3OVER ..
       END
       UNDER
      ;
'(HELP) :
      LIST OFF
      BEGIN
           MENU
           DUP GTZ  % DOES MENU EXIST?
      IF
           SELECTION
           COL#?
           LOCATE
      REPEAT
      DROP
      TEXT
    ;

'HELP : % WILL PROVIDE THE USER WITH AN ONLINE FACILITY TO
          % LOOK UP THINGS 
	SP LNOT IF 'PISTOL.HLP THEN % SUPPLY DEFAULT NAME IF
					% NONE IS PROVIDED
	LOAD
        (HELP)
        CR "HELP COMPLETED" MSG
        0 +7 TRANS W!   % RETURN CONSOLE INPUT
      ;
':'		UNLINK
')'		UNLINK
'COL#?		UNLINK
'MENU		UNLINK
'TEXT		UNLINK
'LOCATE		UNLINK
'SELECTION	UNLINK
'(HELP)		UNLINK


;F

